unit uEventHandler;

interface

uses
  System.Classes, System.SysUtils, System.SyncObjs, System.Generics.Collections, System.Generics.Defaults, System.DateUtils;

const
  EVENT_HANDLER_EXECUTOR_POOL_SIZE = 3;
  EVENT_HANDLER_OK = 0;
  EVENT_HANDLER_DUPLICATE_EVENT_ID = 1;
  EVENT_HANDLER_PROC_NOT_ASSIGNED  = 2;

type
  TEventProc = procedure(Data: TObject; var RepeatInterval: Int64) of object;
  TEventExecuteError = procedure(Data: TObject; Proc: TEventProc; E: Exception) of object;

  TEventId = packed record
  private
    FData: TObject;
    FProc: TEventProc;
  public
    constructor Create(AData: TObject; AProc: TEventProc);
  end;

  TEventRec = class
  strict private
    FTime: TDateTime;
    FGroup: Pointer;
    FSubGroup: Pointer;
    FData: TObject;
    FProc: TEventProc;
    FNeedStop: Boolean;
    FOwnsData: Boolean;

    function GetId: TEventId;
  public
    property Time: TDateTime read FTime write FTime;
    property Group: Pointer read FGroup;
    property SubGroup: Pointer read FSubGroup;
    property Data: TObject read FData;
    property Proc: TEventProc read FProc;
    property Id: TEventId read GetId;
    property NeedStop: Boolean read FNeedStop write FNeedStop;
    property OwnsData: Boolean read FOwnsData;


    constructor Create(const ATime: TDateTime; const AInterval: Int64; AGroup, ASubGroup, AData: Pointer; const AProc: TEventProc; AOwnsData: Boolean);
    destructor Destroy; override;
  end;

  TEventExecutor = class(TThread)
  private
    FEvent: TEvent;
    FEventRec: TEventRec;
    FAllocated: Boolean;
    FOutOfPool: Boolean;
  public
    property Allocated: Boolean read FAllocated write FAllocated;

    constructor Create(AOutOfPool: Boolean = False);
    destructor Destroy; override;

    procedure Execute; override;
    procedure ExecuteEvent(Event: TEventRec);
    procedure Finish;
  end;

  TEventRecComparer = class(TComparer<TEventRec>)
  public
    function Compare(const Left, Right: TEventRec): Integer; override;
  end;

  TEventHandler = class(TThread)
  private
    class var Instance: TEventHandler;
    class var FOnEventExecuteError: TEventExecuteError;

    FEvent: TEvent;
    FLock: TCriticalSection;

    FEventList: TObjectList<TEventRec>;
    FEventIndex: TDictionary<TEventId, TEventRec>;

    FExecutorPoolLock: TCriticalSection;
    FExecutorPool: TList<TEventExecutor>;

    FExecutingList: TDictionary<TEventId, TEventRec>;
    FExecutingListLock: TCriticalSection;

    function NearEvent: TEventRec;
    procedure ExtractEvent(Event: TEventRec);
    function GetExecutor: TEventExecutor;

    procedure StopExecutorPool;

    class procedure InitInstance;
    class function GetExecutorPoolSize: Integer; static;
    class procedure SetExecutorPoolSize(const Value: Integer); static;
    class procedure EventExecuted(Event: TEventRec; RepeatInterval: Int64);
  public
    class property ExecutorPoolSize: Integer read GetExecutorPoolSize write SetExecutorPoolSize;
    class property OnEventExecuteError: TEventExecuteError read FOnEventExecuteError write FOnEventExecuteError;

    constructor Create;
    destructor Destroy; override;

    procedure Execute; override;
    procedure Finish;

    class function AddEvent(Group, SubGroup: Pointer; Data: TObject; Proc: TEventProc; WaitTime: Int64; OwnsData: Boolean = False): Integer; overload;
    class function AddEvent(Group, SubGroup: Pointer; Data: TObject; Proc: TEventProc; StartTime: TDateTime; OwnsData: Boolean = False): Integer; overload;
    class procedure CancelEvent(Data: TObject; Proc: TEventProc; WaitWhileExecuted: Boolean = True);
    class procedure CancelGroupEvents(Group: Pointer; WaitWhileExecuted: Boolean = True);
    class procedure CancelSubGroupEvents(Group, SubGroup: Pointer; WaitWhileExecuted: Boolean = True);
  end;

implementation

{ TEventHandler }

class function TEventHandler.AddEvent(Group: Pointer; SubGroup: Pointer; Data: TObject; Proc: TEventProc;
  WaitTime: Int64; OwnsData: Boolean): Integer;
var
  event: TEventRec;
  event_id: TEventId;
begin
  if not Assigned(Proc) then
    exit(EVENT_HANDLER_PROC_NOT_ASSIGNED);
  InitInstance;
  event_id:= TEventId.Create(Data, Proc);
  Instance.FLock.Enter;
  try
    if Instance.FEventIndex.ContainsKey(event_id) then
      exit(EVENT_HANDLER_DUPLICATE_EVENT_ID);
    event:= TEventRec.Create(IncMilliSecond(Now, WaitTime), WaitTime, Group, SubGroup, Data, Proc, OwnsData);
    Instance.FEventList.Add(event);
    Instance.FEventList.Sort;
    Instance.FEventIndex.Add(event_id, event);
    Instance.FEvent.SetEvent;
  finally
    Instance.FLock.Leave;
  end;
  result:= EVENT_HANDLER_OK;
end;

class function TEventHandler.AddEvent(Group: Pointer; SubGroup: Pointer; Data: TObject; Proc: TEventProc;
  StartTime: TDateTime; OwnsData: Boolean): Integer;
begin
  result:= AddEvent(Group, SubGroup, Data, Proc, MilliSecondsBetween(Now, StartTime), OwnsData);
end;

class procedure TEventHandler.CancelEvent(Data: TObject; Proc: TEventProc; WaitWhileExecuted: Boolean = True);
var
  event: TEventRec;
  event_id: TEventId;
begin
  if Instance = nil then
    exit;
  event_id:= TEventId.Create(Data, Proc);
  Instance.FLock.Enter;
  try
    if Instance.FEventIndex.TryGetValue(event_id, event) then begin
      Instance.FEventIndex.Remove(event_id);
      Instance.FEventList.Remove(event);
      Instance.FEvent.SetEvent;
      exit;
    end;
  finally
    Instance.FLock.Leave;
  end;
  while True do begin
    Instance.FExecutingListLock.Enter;
    try
      if Instance.FExecutingList.TryGetValue(event_id, event) then begin
        if not event.NeedStop then
          event.NeedStop:= True;
        if not WaitWhileExecuted then
          break;
      end else
        break;
    finally
      Instance.FExecutingListLock.Leave;
    end;
    Sleep(0);
  end;
end;

class procedure TEventHandler.CancelGroupEvents(Group: Pointer; WaitWhileExecuted: Boolean = True);
var
  list: TList<TEventRec>;
  event_id: TEventId;
  event: TEventRec;
begin
  if Instance = nil then
    exit;
  list:= TList<TEventRec>.Create;
  try
    Instance.FLock.Enter;
    try
      for event in Instance.FEventList do
        if event.Group = Group then
          list.Add(event);
    finally
      Instance.FLock.Leave;
    end;
    Instance.FExecutingListLock.Enter;
    try
      for event_id in Instance.FExecutingList.Keys do begin
        event:= Instance.FExecutingList[event_id];
        if event.Group = Group then
          list.Add(event);
      end;
    finally
      Instance.FExecutingListLock.Leave;
    end;
    for event in list do
      CancelEvent(event.Data, event.Proc, WaitWhileExecuted);
  finally
    list.Free;
  end;
end;

class procedure TEventHandler.CancelSubGroupEvents(Group, SubGroup: Pointer; WaitWhileExecuted: Boolean = True);
var
  list: TList<TEventRec>;
  event_id: TEventId;
  event: TEventRec;
begin
  if Instance = nil then
    exit;
  list:= TList<TEventRec>.Create;
  try
    Instance.FLock.Enter;
    try
      for event in Instance.FEventList do
        if (event.Group = Group) and (event.SubGroup = SubGroup) then
          list.Add(event);
    finally
      Instance.FLock.Leave;
    end;
    Instance.FExecutingListLock.Enter;
    try
      for event_id in Instance.FExecutingList.Keys do begin
        event:= Instance.FExecutingList[event_id];
        if (event.Group = Group) and (event.SubGroup = SubGroup) then
          list.Add(event);
      end;
    finally
      Instance.FExecutingListLock.Leave;
    end;
    for event in list do
      CancelEvent(event.Data, event.Proc, WaitWhileExecuted);
  finally
    list.Free;
  end;
end;

constructor TEventHandler.Create;
begin
  inherited Create(True);
  FreeOnTerminate:= False;
  FEvent:= TEvent.Create(nil, False, False, EmptyStr);
  FLock:= TCriticalSection.Create;
  FEventList:= TObjectList<TEventRec>.Create(TEventRecComparer.Create, True);
  FEventIndex:= TDictionary<TEventId, TEventRec>.Create;
  FExecutorPoolLock:= TCriticalSection.Create;
  FExecutorPool:= TList<TEventExecutor>.Create;
  FExecutingList:= TDictionary<TEventId, TEventRec>.Create;
  FExecutingListLock:= TCriticalSection.Create;
  Resume;
end;

class procedure TEventHandler.InitInstance;
begin
  if Instance = nil then begin
    Instance:= TEventHandler.Create;
    FOnEventExecuteError:= nil;
    ExecutorPoolSize:= EVENT_HANDLER_EXECUTOR_POOL_SIZE;
  end;
end;

function TEventHandler.NearEvent: TEventRec;
begin
  FLock.Enter;
  try
    if FEventList.Count > 0 then
      exit(FEventList[0]);
    result:= nil;
  finally
    FLock.Leave;
  end;
end;

class procedure TEventHandler.SetExecutorPoolSize(const Value: Integer);
var
  executor: TEventExecutor;
begin
  InitInstance;
  Instance.FExecutorPoolLock.Enter;
  try
    while Instance.FExecutorPool.Count > Value do begin
      executor:= Instance.FExecutorPool.Last;
      executor.Terminate;
      executor.FEvent.SetEvent;
      Instance.FExecutorPool.Delete(Instance.FExecutorPool.Count - 1);
    end;
    while Instance.FExecutorPool.Count < Value do
      Instance.FExecutorPool.Add(TEventExecutor.Create);
  finally
    Instance.FExecutorPoolLock.Leave;
  end;
end;

procedure TEventHandler.Finish;
begin
  inherited Terminate;
  if not Suspended then begin
    FEvent.SetEvent;
    while not Finished do
      Sleep(0);
  end;
end;

procedure TEventHandler.StopExecutorPool;
var
  executor: TEventExecutor;
begin
  for executor in FExecutorPool do
    executor.Finish;
end;

destructor TEventHandler.Destroy;
begin
  if not Terminated then
    Finish;
  FExecutingListLock.Free;
  FExecutingList.Free;

  StopExecutorPool;
  FExecutorPool.Free;

  FExecutorPoolLock.Free;
  FEventIndex.Free;
  FEventList.Free;
  FEvent.Free;
  FLock.Free;
  inherited;
end;

class procedure TEventHandler.EventExecuted(Event: TEventRec; RepeatInterval: Int64);
var
  event_id: TEventId;
begin
  event_id:= Event.Id;
  FExecutingListLock.Enter;
  try
    FExecutingList.Remove(event_id);
  finally
    FExecutingListLock.Leave;
  end;
  if Event.NeedStop or (RepeatInterval = 0) then
    Event.Free
  else begin
    Event.Time:= IncMilliSecond(Now, RepeatInterval);
    Instance.FLock.Enter;
    try
      Instance.FEventList.Add(Event);
      Instance.FEventList.Sort;
      Instance.FEventIndex.Add(event_id, Event);
      Instance.FEvent.SetEvent;
    finally
      Instance.FLock.Leave;
    end;
  end;
end;

procedure TEventHandler.Execute;
var
  event: TEventRec;
  wait_time: Int64;
  part_wait: Boolean;
begin
  while not Terminated do begin
    event:= NearEvent;
    if event <> nil then begin
      if CompareDateTime(event.Time, Now) <= 0 then
        wait_time:= 0
      else
        wait_time:= MilliSecondsBetween(Now, event.Time);
      if wait_time >= INFINITE then begin
        wait_time:= INFINITE - 1;
        part_wait:= True;
      end else
        part_wait:= False;
      if FEvent.WaitFor(wait_time) = wrTimeout then begin
        if part_wait then
          continue;
        ExtractEvent(event);
        GetExecutor.ExecuteEvent(event);
      end;
    end else
      FEvent.WaitFor(INFINITE);
  end;
end;

procedure TEventHandler.ExtractEvent(Event: TEventRec);
var
  event_id: TEventId;
begin
  event_id:= Event.Id;
  FLock.Enter;
  try
    FEventList.Extract(Event);
    FEventIndex.Remove(event_id);
    FExecutingListLock.Enter;
    try
      FExecutingList.Add(event_id, Event);
    finally
      FExecutingListLock.Leave;
    end;
  finally
    FLock.Leave;
  end;
end;

function TEventHandler.GetExecutor: TEventExecutor;
var
  executor: TEventExecutor;
begin
  FExecutorPoolLock.Enter;
  try
    for executor in FExecutorPool do
      if not executor.Allocated then begin
        executor.Allocated:= True;
        exit(executor);
      end;
  finally
    FExecutorPoolLock.Leave;
  end;
  result:= TEventExecutor.Create(True);
end;

class function TEventHandler.GetExecutorPoolSize: Integer;
begin
  InitInstance;
  result:= Instance.FExecutorPool.Count;
end;

{ TEventRec }

constructor TEventRec.Create(const ATime: TDateTime; const AInterval: Int64; AGroup, ASubGroup, AData: Pointer;
  const AProc: TEventProc; AOwnsData: Boolean);
begin
  FTime:= ATime;
  FGroup:= AGroup;
  FSubGroup:= ASubGroup;
  FData:= AData;
  FProc:= AProc;
  FNeedStop:= False;
  FOwnsData:= AOwnsData;
end;

destructor TEventRec.Destroy;
begin
  if FOwnsData then
    FData.Free;
  inherited;
end;

function TEventRec.GetId: TEventId;
begin
  result.Create(FData, FProc);
end;

{ TEventExecutor }

constructor TEventExecutor.Create(AOutOfPool: Boolean);
begin
  inherited Create(True);
  FreeOnTerminate:= True;
  FEvent:= TEvent.Create(nil, False, False, EmptyStr);
  FEventRec:= nil;
  FOutOfPool:= AOutOfPool;
  FAllocated:= False;
  Resume;
end;

destructor TEventExecutor.Destroy;
begin
  if not Terminated then
    Finish;
  FEvent.Free;
  inherited;
end;

procedure TEventExecutor.Execute;
var
  repeat_interval: Int64;
begin
  while not Terminated do begin
    FEvent.WaitFor(INFINITE);
    if not Terminated then begin
      try
        try
          repeat_interval:= 0;
          FEventRec.Proc(FEventRec.Data, repeat_interval);
        except
          on E: Exception do
            if Assigned(TEventHandler.OnEventExecuteError) then
              try
                TEventHandler.OnEventExecuteError(FEventRec.Data, FEventRec.Proc, E);
              except
              end;
        end;
        if FOutOfPool then
          break;
      finally
        TEventHandler.EventExecuted(FEventRec, repeat_interval);
        FAllocated:= False;
      end;
    end;
  end;
end;

procedure TEventExecutor.ExecuteEvent(Event: TEventRec);
begin
  FEventRec:= Event;
  FEvent.SetEvent;
end;

procedure TEventExecutor.Finish;
begin
  inherited Terminate;
  if not Suspended then begin
    FEvent.SetEvent;
    while not Finished do
      Sleep(0);
  end;
end;

{ TEventRecComparer }

function TEventRecComparer.Compare(const Left, Right: TEventRec): Integer;
begin
  result:= CompareDateTime(Left.Time, Right.Time);
end;

{ TEventId }

constructor TEventId.Create(AData: TObject; AProc: TEventProc);
begin
  FData:= AData;
  FProc:= AProc;
end;

initialization
begin
  TEventHandler.Instance:= nil;
end;

finalization
begin
  FreeAndNil(TEventHandler.Instance);
end;

end.
